home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / src-16f.lha / code / mach.lisp < prev    next >
Encoding:
Text File  |  1992-05-30  |  4.8 KB  |  169 lines
  1. ;;; -*- Package: MACH -*-
  2. ;;;
  3. ;;; **********************************************************************
  4. ;;; This code was written as part of the CMU Common Lisp project at
  5. ;;; Carnegie Mellon University, and has been placed in the public domain.
  6. ;;; If you want to use this code or any part of CMU Common Lisp, please contact
  7. ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
  8. ;;;
  9. (ext:file-comment
  10.   "$Header: mach.lisp,v 1.3 92/02/15 13:00:05 wlott Exp $")
  11. ;;;
  12. ;;; **********************************************************************
  13. ;;;
  14. ;;; This file contains the low-level support for MACH features not found
  15. ;;; in UNIX.
  16. ;;;
  17.  
  18. (in-package "MACH")
  19. (use-package "ALIEN")
  20. (use-package "C-CALL")
  21. (use-package "SYSTEM")
  22.  
  23. (export '(port mach-task_self mach-task_data mach-task_notify
  24.       kern-success get-mach-error-msg
  25.       gr-error gr-call gr-call* gr-bind
  26.       vm_allocate vm_copy vm_deallocate vm_statistics))
  27.  
  28.  
  29. ;;;; Standard ports.
  30.  
  31. (def-alien-type port int)
  32.  
  33. (def-alien-routine ("task_self" mach-task_self) port)
  34. (def-alien-routine ("thread_reply" mach-task_data) port)
  35. (def-alien-routine ("task_notify" mach-task_notify) port)
  36.  
  37.  
  38.  
  39. ;;;; Return codes.
  40.  
  41. (def-alien-type kern-return int)
  42.  
  43. (defconstant kern-success 0)
  44. (defconstant kern-invalid-address 1)
  45. (defconstant kern-protection-failure 2)
  46. (defconstant kern-no-space 3)
  47. (defconstant kern-invalid-argument 4)
  48. (defconstant kern-failure 5)
  49. (defconstant kern-resource-shortage 6)
  50. (defconstant kern-not-receiver 7)
  51. (defconstant kern-no-access 8)
  52. (defconstant kern-memory-failure 9)
  53. (defconstant kern-memory-error 10)
  54. (defconstant kern-already-in-set 11)
  55. (defconstant kern-not-in-set 12)
  56. (defconstant kern-name-exists 13)
  57. (defconstant kern-aborted 14)
  58. (defconstant kern-memory-present 23)
  59.  
  60. (def-alien-routine ("mach_error_string" get-mach-error-msg) c-string
  61.   (errno kern-return))
  62.  
  63. ;;; GR-Error  --  Public
  64. ;;;
  65. (defun gr-error (function gr &optional context)
  66.   "Signal an error indicating that Function returned code GR.  If the code
  67.   is success, then do nothing."
  68.   (unless (eql gr kern-success)
  69.     (error "~S~@[ ~A~], ~(~A~)." function context (get-mach-error-msg gr))))
  70.  
  71. ;;; GR-Call  --  Public
  72. ;;;
  73. (defmacro gr-call (fun &rest args)
  74.   "GR-Call Function {Arg}*
  75.   Call the function with the specified Args and signal an error if the
  76.   first value returned is not mach:kern-success.  Nil is returned."
  77.   (let ((n-gr (gensym)))
  78.     `(let ((,n-gr (,fun ,@args)))
  79.        (unless (eql ,n-gr kern-success) (gr-error ',fun ,n-gr)))))
  80.  
  81. ;;; GR-Call*  --  Public
  82. ;;;
  83. (defmacro gr-call* (fun &rest args)
  84.   "GR-Call* Function {Arg}*
  85.   Call the function with the specified Args and signal an error if the
  86.   first value returned is not mach:kern-success.  The second value is
  87.   returned."
  88.   (let ((n-gr (gensym))
  89.     (n-res (gensym)))
  90.     `(multiple-value-bind (,n-gr ,n-res) (,fun ,@args)
  91.        (unless (eql ,n-gr kern-success) (gr-error ',fun ,n-gr))
  92.        ,n-res)))
  93.  
  94. ;;; GR-Bind  --  Public
  95. ;;;
  96. (defmacro gr-bind (vars (fun . args) &body (body decls))
  97.   "GR-Bind ({Var}*) (Function {Arg}*) {Form}*
  98.   Call the function with the specified Args and signal an error if the
  99.   first value returned is not mach:Kern-Success.  If the call succeeds,
  100.   the Forms are evaluated with remaining return values bound to the
  101.   Vars."
  102.   (let ((n-gr (gensym)))
  103.     `(multiple-value-bind (,n-gr ,@vars) (,fun ,@args)
  104.        ,@decls
  105.        (unless (eql ,n-gr kern-success) (gr-error ',fun ,n-gr))
  106.        ,@body)))
  107.  
  108.  
  109.  
  110. ;;;; VM routines.
  111.  
  112. (export '(vm_allocate vm_copy vm_deallocate vm_statistics))
  113.  
  114. (def-alien-routine ("vm_allocate" vm_allocate) int
  115.   (task port)
  116.   (address system-area-pointer :in-out)
  117.   (size unsigned-long)
  118.   (anywhere boolean))
  119.  
  120. (def-alien-routine ("vm_copy" vm_copy) int
  121.   (task port)
  122.   (source system-area-pointer)
  123.   (count unsigned-long)
  124.   (dest system-area-pointer))
  125.  
  126. (def-alien-routine ("vm_deallocate" vm_deallocate) int
  127.   (task port)
  128.   (address system-area-pointer)
  129.   (size unsigned-long))
  130.  
  131.  
  132. (def-alien-type nil
  133.   (struct vm_statistics
  134.     (pagesize long)
  135.     (free_count long)
  136.     (active_count long)
  137.     (inactive_count long)
  138.     (wire_count long)
  139.     (zero_fill_count long)
  140.     (reactivations long)
  141.     (pageins long)
  142.     (pageouts long)
  143.     (faults long)
  144.     (cow_faults long)
  145.     (lookups long)
  146.     (hits long)))
  147.  
  148. (defun vm_statistics (task)
  149.   (with-alien ((vm_stats (struct vm_statistics)))
  150.     (values
  151.      (alien-funcall (extern-alien "vm_statistics"
  152.                   (function int
  153.                         port
  154.                         (* (struct vm_statistics))))
  155.             task (alien-sap vm_stats))
  156.      (slot vm_stats 'pagesize)
  157.      (slot vm_stats 'free_count)
  158.      (slot vm_stats 'active_count)
  159.      (slot vm_stats 'inactive_count)
  160.      (slot vm_stats 'wire_count)
  161.      (slot vm_stats 'zero_fill_count)
  162.      (slot vm_stats 'reactivations)
  163.      (slot vm_stats 'pageins)
  164.      (slot vm_stats 'pageouts)
  165.      (slot vm_stats 'faults)
  166.      (slot vm_stats 'cow_faults)
  167.      (slot vm_stats 'lookups)
  168.      (slot vm_stats 'hits))))
  169.